home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 2.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.4 / ice-9 / arrays.scm.z / arrays.scm
Text File  |  2002-07-08  |  3KB  |  84 lines
  1. ;;; installed-scm-file
  2.  
  3. ;;;; Copyright (C) 1999 Free Software Foundation, Inc.
  4. ;;;; 
  5. ;;;; This program is free software; you can redistribute it and/or modify
  6. ;;;; it under the terms of the GNU General Public License as published by
  7. ;;;; the Free Software Foundation; either version 2, or (at your option)
  8. ;;;; any later version.
  9. ;;;; 
  10. ;;;; This program is distributed in the hope that it will be useful,
  11. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. ;;;; GNU General Public License for more details.
  14. ;;;; 
  15. ;;;; You should have received a copy of the GNU General Public License
  16. ;;;; along with this software; see the file COPYING.  If not, write to
  17. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18. ;;;; Boston, MA 02111-1307 USA
  19. ;;;; 
  20.  
  21. (define uniform-vector? array?)
  22. (define make-uniform-vector dimensions->uniform-array)
  23.  
  24. ;;  (define uniform-vector-ref array-ref)
  25.  
  26. (define (uniform-vector-set! u i o)
  27.   (uniform-array-set1! u o i))
  28. (define uniform-vector-fill! array-fill!)
  29. (define uniform-vector-read! uniform-array-read!)
  30. (define uniform-vector-write uniform-array-write)
  31.  
  32. (define (make-array fill . args)
  33.   (dimensions->uniform-array args () fill))
  34. (define (make-uniform-array prot . args)
  35.   (dimensions->uniform-array args prot))
  36. (define (list->array ndim lst)
  37.   (list->uniform-array ndim '() lst))
  38. (define (list->uniform-vector prot lst)
  39.   (list->uniform-array 1 prot lst))
  40. (define (array-shape a)
  41.   (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
  42.        (array-dimensions a)))
  43.  
  44. (let ((make-array-proc (lambda (template)
  45.              (lambda (c port)
  46.                (read:uniform-vector template port)))))
  47.   (for-each (lambda (char template)
  48.           (read-hash-extend char
  49.                 (make-array-proc template)))
  50.         '(#\b #\a #\u #\e #\s #\i #\c #\y   #\h #\l)
  51.         '(#t  #\a 1   -1  1.0 1/3 0+i #\nul s   l)))
  52.  
  53. (let ((array-proc (lambda (c port)
  54.             (read:array c port))))
  55.   (for-each (lambda (char) (read-hash-extend char array-proc))
  56.           '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))
  57.  
  58. (define (read:array digit port)
  59.   (define chr0 (char->integer #\0))
  60.   (let ((rank (let readnum ((val (- (char->integer digit) chr0)))
  61.         (if (char-numeric? (peek-char port))
  62.             (readnum (+ (* 10 val)
  63.                 (- (char->integer (read-char port)) chr0)))
  64.             val)))
  65.     (prot (if (eq? #\( (peek-char port))
  66.           '()
  67.           (let ((c (read-char port)))
  68.             (case c ((#\b) #t)
  69.               ((#\a) #\a)
  70.               ((#\u) 1)
  71.               ((#\e) -1)
  72.               ((#\s) 1.0)
  73.               ((#\i) 1/3)
  74.               ((#\c) 0+i)
  75.               (else (error "read:array unknown option " c)))))))
  76.     (if (eq? (peek-char port) #\()
  77.     (list->uniform-array rank prot (read port))
  78.     (error "read:array list not found"))))
  79.  
  80. (define (read:uniform-vector proto port)
  81.   (if (eq? #\( (peek-char port))
  82.       (list->uniform-array 1 proto (read port))
  83.       (error "read:uniform-vector list not found")))
  84.